home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD Classic 39
/
CD CLASSIC #39 (1998).iso
/
EMPRESA
/
visio
/
Vistdstd
/
Install
/
Data.Z
/
Orgchart.BAS
< prev
next >
Wrap
BASIC Source File
|
1996-09-05
|
34KB
|
842 lines
Attribute VB_Name = "ORGCHART1"
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'--
'-- Visio Organization Chart AddOn
'-- (C)1993 Shapeware Corporation
'--
'-- File Name : OrgChart.bas
'--
'-- Description : Main module for the OrgChart AddOn
'--
'-- Audit Trail:
'--
'-- 09/**/93 - v2.001 - aw - The procedures that have comments in them are modified,
'-- all totally changed. Code has been deleted, and bugs that
'-- had to do with reading orgchart from Visio is corrected.
'-- CreateOrgChart now colors the 2D shapes again.
'-- ReadOrgChart can read the orgchart both when user uses
'-- a combination of 1D and 2D shapes, or 2D shapes and control
'-- points. In the case of 2D/1D, the y-value of the 2D shape's
'-- connection point (where the 1D shape is connected )decides
'-- which 2D shape is partent of another 2D shape.
'-- 07/**/93 - v2.000 - bl - Added code for read orgchart in menu chart.
'-- **/**/** - v1.001 - rf - Updated code.
'-- **/**/** - v1.000 - ** - Created.(PM or TB)
'--
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
Option Explicit
'Option Base 1
'Maximum number of objects for arrays used when create orgchart
Global Const cMax% = 60
'-- Constants used to identify the items in the chart menu
Global Const ShowItems% = 0
Global Const CreateChart% = 1
Global Const ReadChart% = 2
'-- Constants used to identify the items in the command menu
Global Const Promote% = 0
Global Const Demote% = 1
Global Const Delet% = 2
Global Const DeleteBranch% = 3
'-- Used when ask user to clear the orgchart scetched in the outline control
Global Const MB_YESNO = 4
Global Const IDNO = 7
'-- Key Codes
Global Const KEY_BACK = &H8
Global Const KEY_TAB = &H9
Global Const KEY_SHIFT = &H10
Global Const KEY_RETURN = &HD
Global Const KEY_LEFT = &H25
Global Const KEY_UP = &H26
Global Const KEY_RIGHT = &H27
Global Const KEY_DOWN = &H28
Global Const SHIFT_MASK = 1
Global Const CTRL_MASK = 2
Global Const ALT_MASK = 4
Global Const CURSOR_HOURGLASS = 11
Global Const CURSOR_NORMAL = 1
Function BuildOneD(cShapesCount As Integer, objDocument As Visio.Document) As String
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: ReadOrgChart()
'-- Functions called:
'-- This function has an effect only when the user has connected the 2D
'-- BuildOneD loops through all the shapes, if it's a one dimensional shape, it checks it's
'-- connections, and saves what is connected to what. This function uses heuristics, it assumes
'-- that if a 1D shape is glued to the bottom most connection point of the 2D shape, (connection
'-- no 4), this 2D shape is the parent of the shape in the other end of the 1D which will be
'-- connections no 2. Format of the string will be: {003 001}{002 001}.... if 003 and 002
'-- are children of 001
'--
Dim i As Integer
Dim strS As String
Dim objShapes As Visio.Shapes, objConnections As Visio.Connects
Dim TB As String
TB = Chr$(9)
Set objShapes = objDocument.Pages(1).Shapes
For i = 1 To cShapesCount
If objShapes(i).OneD Then
Set objConnections = objShapes(i).Connects
If (objConnections.Count = 2) Then
'Connections(1) has highest y-value (highest y-value = from shape)
If objConnections(1).ToPart = (visConnectionPoint + visRowFirst + 1) Then
strS = strS & "{" & Format$(objConnections(1).ToSheet.Index, "000") & TB & Format$(objConnections(2).ToSheet.Index, "000") & "}"
Else 'Connections(2) has highest y-value
strS = strS & "{" & Format$(objConnections(2).ToSheet.Index, "000") & TB & Format$(objConnections(1).ToSheet.Index, "000") & "}"
End If
End If
End If
Next i
BuildOneD = strS
End Function
Function BuildTwoD(cShapesCount As Integer, objDocument As Visio.Document) As String
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: ReadOrgChart()
'-- Functions called:
'-- BuildTwoD loops through all the shapes, and if it's a two dimensional shape it checks it's
'-- connections, and saves what is connected to what. Format of the string will be..
'-- 001PeterCR
'-- 002TroyCR
'-- 003AirenCR.....
'--
Dim i As Integer
Dim strS As String
Dim objShapes As Visio.Shapes, objConnections As Visio.Connects
Dim CR As String, TB As String
CR = Chr$(13): TB = Chr$(9)
Set objShapes = objDocument.Pages(1).Shapes
For i = 1 To cShapesCount
If Not objShapes(i).OneD Then
strS = strS & Format$(Str$(i), "000") & objShapes(i).Text '& CR
Set objConnections = objShapes(i).Connects
'-- This is only the case if the user choses to use the 2D shape's control point to
'-- to connect to another shape instead of 1D connectors.
If objConnections.Count > 0 Then
strS = strS & TB & Format$(objConnections(1).ToSheet.Index, "000")
End If
strS = strS & CR
End If
Next i
BuildTwoD = strS
End Function
Sub ConvertStr(strTwoD As String, cShapesCount As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: ReadOrgChart()
'-- Functions called:
'-- ConvertStr loops through all the shapes in strTwoD and changes the format from being a list
'-- of shapes, each followed by their parent, to a list of shapes, each followed by their
'-- children.
'--
Dim i As Integer, iTab As Integer, iPos As Integer, iCr As Integer
Dim strParent As String, strShape As String, strRside As String
Dim CR As String, TB As String
CR = Chr$(13): TB = Chr$(9)
For i = 1 To cShapesCount
iPos = InStr(strTwoD, Format$(i, "000"))
If iPos <> 0 Then
strShape = Mid$(strTwoD, iPos, 3)
iCr = InStr(iPos, strTwoD, CR)
iTab = InStr(iPos, strTwoD, TB)
'-- Take the parent and find the line it's on, and add the current shape
'-- to it's list of children.
If iTab <> 0 And iTab < iCr Then
strParent = Mid$(strTwoD, iTab + 1, 3)
iPos = InStr(strTwoD, CR & strParent)
iPos = iPos + 1 '-- Get pass the CR character
iCr = InStr(iPos, strTwoD, CR)
strRside = Right$(strTwoD, Len(strTwoD) - (iCr - 1))
strTwoD = Left$(strTwoD, iCr - 1) & "#" & strShape & strRside
'-- Go back to the current shape again, and remove the parent in the list.
iPos = InStr(strTwoD, Format$(i, "000"))
iPos = InStr(iPos, strTwoD, TB & strParent)
strRside = Right$(strTwoD, Len(strTwoD) - (iPos + 3))
strTwoD = Left$(strTwoD, iPos - 1) & strRside
End If
End If
Next i
End Sub
Sub CreateOrgChart()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: frmOrgChart.mnuChartItem_Click()
'-- Functions called: DrawOrgChart()
'-- CreateOrgChart loops through the items in the form's outline control and finds the max level,
'-- numbers of leaves, and parent chain. It calls DrawOrgChart which draws the organizational
'-- chart in Visio.
'--
ReDim rgParent(cMax) As Integer, rgLeft(cMax) As Integer, rgRight(cMax) As Integer
Dim cLevels As Integer, cLeaves As Integer, fIsLeaf As Integer
Dim iIndex As Integer, iIndent As Integer
cLevels = 0
cLeaves = 0
For iIndex = 0 To frmOrgChart.Outline1.ListCount - 1
If frmOrgChart.Outline1.Indent(iIndex) < 1 Then
rgParent(iIndex) = -1 'the root, has no parent
ElseIf frmOrgChart.Outline1.Indent(iIndex) > frmOrgChart.Outline1.Indent(iIndex - 1) Then
rgParent(iIndex) = iIndex - 1
Else
iIndent = iIndex - 1
While frmOrgChart.Outline1.Indent(iIndex) <> frmOrgChart.Outline1.Indent(iIndent)
iIndent = rgParent(iIndent)
Wend
rgParent(iIndex) = rgParent(iIndent)
End If
'-- The item is a leaf if it doesn't have any children
fIsLeaf = Not (frmOrgChart.Outline1.HasSubItems(iIndex))
'-- If it's a leaf, then set it's left- and right "pointer" to NULL
If Not fIsLeaf Then
rgLeft(iIndex) = -1
rgRight(iIndex) = -1
Else
rgLeft(iIndex) = cLeaves
rgRight(iIndex) = cLeaves
iIndent = rgParent(iIndex)
While iIndent <> -1
If rgLeft(iIndent) = -1 Then rgLeft(iIndent) = cLeaves
rgRight(iIndent) = cLeaves
iIndent = rgParent(iIndent)
Wend
End If
If frmOrgChart.Outline1.Indent(iIndex) > cLevels Then
cLevels = frmOrgChart.Outline1.Indent(iIndex)
End If
If fIsLeaf Then cLeaves = cLeaves + 1
Next iIndex
DrawOrgChart rgParent(), rgLeft(), rgRight(), cLeaves, cLevels
Exit Sub
End Sub
Sub DeleteItem()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: frmOrgChart.mnuCommandItem()
'-- Functions called: SuperExpand(), PromoteChild(), TopExpand(), UpdateFields()
'-- DeleteItem has to update the indentation level for all of the children of the item to be
'-- deleted before the item is removed since otherwise the children will be deleted as well.
'--
Dim ctl As Control
'Short form...
Set ctl = frmOrgChart.Outline1
'SuperExpand (ctl.ListIndex)
Select Case ctl.ListIndex
Case -1:
Beep '-- Nothing in the outline control
Case 0: '-- Try to delete the root
If ctl.HasSubItems(ctl.ListIndex) Then
Beep
'If one child - ok
'If more than one child then tell user it cannot be done
Else
ctl.RemoveItem ctl.ListIndex
End If
Case Else:
'-- Delete the item after all of it's children's indent have been updated.
PromoteChild ctl.ListIndex + 1, (ctl.Indent(ctl.ListIndex))
ctl.RemoveItem ctl.ListIndex
End Select
UpdateFields
End Sub
Sub DeleteItemBranch()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: frmOrgChart.mnuCommandItem()
'-- Functions called:
'-- DeleteItemBranch deletes the item identified by ListIndex, and all of it's children.
'-- (RemoveItem method removes the item and all of it's subordinate items for an outline
'-- control).
'--
Dim ctl As Control
'Short form...
Set ctl = frmOrgChart.Outline1
If ctl.ListIndex <> -1 Then
ctl.RemoveItem (ctl.ListIndex)
frmOrgChart.Outline1.AddItem ""
ctl.ListIndex = 0
ctl.Indent(ctl.ListIndex) = 0
UpdateFields
Else
Beep
End If
End Sub
Sub DemoteChild(iIndex As Integer, iIndent As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: DeleteItem()
'-- Functions called: DemoteChild() - recursive
'-- DemoteChild loops through the children of the item (items in the list can be children if
'-- their index follow in sequence after the index of The item, and they have an indentation
'-- larger than the indentation for The item.)
'--
Dim ctl As Control
'-- Short form...
Set ctl = frmOrgChart.Outline1
'-- Stop recursion at this point..
If iIndex = ctl.ListCount Then
Exit Sub
ElseIf Not ctl.Indent(iIndex) > iIndent Then
Exit Sub
End If
'-- Adjust indentation..
ctl.Indent(iIndex) = ctl.Indent(iIndex) + 1
SuperExpand iIndex
'-- Call recursively..
DemoteChild iIndex + 1, iIndent
End Sub
Sub DemoteItem()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: mnuCommandItem()
'-- Functions called: DemoteChild()
'-- DemoteItem adjust the indentation for the item itself, and then adjust the indentation
'-- for the item's child. However, if the outline control is empty or the item is the root,
'-- or the item doesn't have a preceding item with indent level equal or greater to it's own,
'-- it'll just beep.
'--
Dim ctl As Control
Dim iIndent As Integer
'Short form...
Set ctl = frmOrgChart.Outline1
If ctl.ListIndex <> -1 Then
'-- Cannot demote the item if it's a root, or if there's no item preceding it with
'-- indent level equal or larger to it's own indent level.
If ctl.Indent(ctl.ListIndex) > 0 Then
If Not ctl.Indent(ctl.ListIndex - 1) < ctl.Indent(ctl.ListIndex) Then
iIndent = ctl.Indent(ctl.ListIndex)
ctl.Indent(ctl.ListIndex) = ctl.Indent(ctl.ListIndex) + 1
'-- It still eludes me why they disappear, but for now solve
'-- the problem by expanding..
SuperExpand (ctl.ListIndex)
DemoteChild ctl.ListIndex + 1, iIndent
Else
Beep
End If
Else
Beep
End If
Else
Beep
End If
End Sub
Private Sub DrawOrgChart(rgParent() As Integer, rgLeft() As Integer, rgRight() As Integer, cLeaves As Integer, cLevels As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: CreateOrgChart()
'-- Functions called: GlueMe(), PosX(), PosY()
'-- DrawOrgChart sets up the environment in Visio (exits if it cannot create or get the
'-- existing Visio) and then drops instances of the master "Position" onto the page according
'-- to the number of items in the form's outline control. It assigns text to the instances, sets
'-- their fill color, and calls GlueMe in order to connect the different instances of "Position".
'--
ReDim objArray(cMax) As Object
Dim objPage As Visio.Page, objStencil As Visio.Document, objMasters As Visio.Masters
Dim objMaster As Visio.Master, objParent As Object, objShapes As Visio.Shapes
Dim iIndex As Integer, iIndent As Integer
Dim X As Double, Y As Double
'Get the active instance of Visio, or run one
If vaoGetObject() <> visOK Then
MsgBox "Cannot get an instance of Visio."
End
End If
'Create a new document based on sample.vst
'and get the stencil, master, and page objects
g_appVisio.Documents.Add ("VB Solutions.vst")
Set objStencil = g_appVisio.Documents.Item("VB Solutions.vss")
Set objMasters = objStencil.Masters
Set objMaster = objMasters.Item("Position")
Set objPage = g_appVisio.ActivePage
'Calculat the pin of each Position shape based on cLeaves and cLevels.
For iIndex = 0 To frmOrgChart.Outline1.ListCount - 1
X = PosX(cLeaves, rgRight(iIndex), rgLeft(iIndex))
Y = PosY(cLevels, iIndex)
Set objArray(iIndex) = objPage.Drop(objMaster, X, Y)
objArray(iIndex).Text = (frmOrgChart.Outline1.List(iIndex))
Set objShapes = objArray(iIndex).Shapes
Next iIndex
'Glue each child to its parent
For iIndex = 0 To frmOrgChart.Outline1.ListCount - 1
iIndent = rgParent(iIndex)
If iIndent <> -1 Then
objArray(iIndex).Cells("Controls.X1").GlueTo objArray(rgParent(iIndex)).Cells("Connections.X4")
End If
Next iIndex
End Sub
Function FindRoot(strTwoD As String) As String
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: ReadOrgChart()
'-- Functions called:
'-- FindRoot loops through all the shapes and decides which shape is the root in the
'-- organizational tree.
'--
Dim iTab As Integer, iCr As Integer, iPos As Integer, iStart As Integer
Dim CR As String, TB As String, strRoot As String
CR = Chr$(13): TB = Chr$(9)
iStart = 1
strRoot = Mid$(strTwoD, iStart, 3)
iTab = InStr(iStart, strTwoD, TB)
iCr = InStr(iStart, strTwoD, CR)
Do While (iTab < iCr)
iStart = iCr + 1
strRoot = Mid$(strTwoD, iStart, 3)
iTab = InStr(iStart, strTwoD, TB)
iCr = InStr(iStart, strTwoD, CR)
Loop
FindRoot = strRoot
End Function
Sub ImportStr(strTwoD As String, ByVal strTop As String, Indent As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: ReadOrgChart()
'-- Functions called: ImportStr() - recursive
'-- ImportStr loops through all the shapes in strTwoD and sketches the outline of the
'-- organizational chart in the form's outline control.
'--
Dim i As Integer, iPos As Integer, iNo As Integer, iCr As Integer
Dim strNewTop As String, temp As String
Dim CR As String, TB As String
CR = Chr$(13): TB = Chr$(9)
strNewTop = strTop
iPos = InStr(1, strTwoD, strNewTop)
If iPos <> 1 Then
While Mid$(strTwoD, iPos - 1, 1) = "#"
iPos = InStr(iPos + 1, strTwoD, strNewTop)
Wend
End If
iPos = iPos + 3
iCr = InStr(iPos, strTwoD, CR)
iNo = InStr(iPos, strTwoD, "#")
If iNo <> 0 And iNo < iCr Then
temp = Mid$(strTwoD, iPos, iNo - iPos)
Else
temp = Mid$(strTwoD, iPos, iCr - iPos)
End If
frmOrgChart.Outline1.AddItem temp
frmOrgChart.Outline1.Indent(frmOrgChart.Outline1.ListCount - 1) = Indent
Do While iNo <> 0 And iNo < iCr
temp = Mid$(strTwoD, iNo + 1, 3)
ImportStr strTwoD, temp, Indent + 1
iNo = InStr(iNo + 1, strTwoD, "#")
Loop
End Sub
Sub MergeStr(strOneDShapes As String, strTwoDShapes As String)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: ReadOrgChart()
'-- Functions called:
'-- MergeStr merges the two strings, strOneD and strTwoD, and leave the result in strTwoD.
'-- (If the user has used the 2D shape's control point to connect to the other shape,
'-- no merging is needed.)
'--
Dim iConnections As Integer, i As Integer, iCr As Integer, iPos As Integer
Dim iStart1 As Integer, iStart2 As Integer
Dim strFrom As String, strTo As String
Dim CR As String, TB As String
CR = Chr$(13): TB = Chr$(9)
iStart1 = 2: iStart2 = 1
iConnections = Len(strOneDShapes) / 9
For i = 1 To iConnections 'Parent/Child connections
'-- String of OneD shapes...
strFrom = Mid$(strOneDShapes, iStart1, 3)
iStart1 = iStart1 + 4
strTo = Mid$(strOneDShapes, iStart1, 3)
'-- String of TwoD shapes...
iPos = InStr(1, strTwoDShapes, strFrom)
iStart2 = iPos
iCr = InStr(iStart2, strTwoDShapes, CR)
'If we're at the end of the string, prepare for appending....
If iCr = 0 Then
iCr = Len(strTwoDShapes) + 1
End If
strFrom = Right$(strTwoDShapes, Len(strTwoDShapes) - (iCr - 1))
strTwoDShapes = Left$(strTwoDShapes, iCr - 1) & TB & strTo & strFrom
iStart1 = iStart1 + 5
Next i
End Sub
Sub movedown()
'/************* Needs to be worked on *********/
Dim dumnum As Variant
Dim intnum As Integer
Dim intabv As Integer
Dim intblw As Integer
Dim strT As String
Dim ctl As Control
'-- short form...
Set ctl = frmOrgChart.Outline1
ctl.Refresh
If ctl.ListIndex = 0 Then
Beep
Exit Sub
End If
intnum = ctl.ListIndex + 1
If ctl.ListCount - intnum > 0 Then
dumnum = Abs(ctl.Indent(intnum) - ctl.Indent(ctl.ListIndex))
If dumnum > 1 Then
Beep
Exit Sub
Else
intblw = ctl.Indent(intnum)
End If
Else
Beep
Exit Sub
End If
intnum = intnum - 2
If intnum > -1 Then
intabv = ctl.Indent(intnum)
Else
intabv = intblw
End If
If (ctl.ListIndex + 2) < ctl.ListCount Then
intnum = Abs(ctl.Indent(ctl.ListIndex) - ctl.Indent(ctl.ListIndex + 2))
Else
intnum = 1
End If
dumnum = Abs(intabv - intblw)
If dumnum < 2 And intnum < 2 Then
strT = ctl.List(ctl.ListIndex)
ctl.List(ctl.ListIndex) = ctl.List(ctl.ListIndex + 1)
ctl.List(ctl.ListIndex + 1) = strT
ctl.Indent(ctl.ListIndex + 1) = ctl.Indent(ctl.ListIndex)
ctl.Indent(ctl.ListIndex) = intblw
ctl.ListIndex = ctl.ListIndex + 1
SuperExpand (ctl.ListIndex)
TopExpand (ctl.ListIndex)
Else
Beep
End If
End Sub
Sub moveup()
'/******** Needs to be worked on ********/
Dim Thing As String
Dim ctl As Control
'-- Short form...
Set ctl = frmOrgChart.Outline1
Thing = ctl.List(ctl.ListIndex)
If ctl.ListIndex - 1 >= 0 Then
ctl.ListIndex = ctl.ListIndex - 1
movedown
If ctl.ListIndex + 1 >= ctl.ListCount Then
ctl.ListIndex = ctl.ListIndex - 1
Exit Sub
End If
If ctl.List(ctl.ListIndex + 1) <> Thing Then
ctl.ListIndex = ctl.ListIndex - 1
Else
ctl.ListIndex = ctl.ListIndex + 1
End If
Else
Beep
End If
End Sub
Private Function PosX(cLeaves As Integer, aright As Integer, aleft As Integer) As Double
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling funcions: DrawOrgChart()
'-- Functions called:
'-- PosX calculates the x position for where to drop the instance of the master based on how
'-- many children the object has.
'--
Dim MulX As Double, OffX As Double
MulX = 1.25
OffX = 5# - (1# * cLeaves) / 2
PosX = OffX + MulX * (aright + aleft) / 2#
End Function
Private Function PosY(cLevels As Integer, Index As Integer) As Double
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling funcions: DrawOrgChart()
'-- Functions called:
'-- PosY calculates the y position for where to drop the instance of the master based on how
'-- many levels the tree has.
'--
Dim OffY As Double
Dim separation As Double
separation = 1
OffY = 4.5 + (cLevels * separation) / 2
PosY = OffY - (frmOrgChart.Outline1.Indent(Index)) * separation
End Function
Sub PromoteChild(iIndex As Integer, iIndent As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: DeleteItem()
'-- Functions called: PromoteChild() - recursive
'-- PromoteChild loops through the children of The item (items in the list can be children if
'-- their index follow in sequence after the index of The item, and they have an indentation
'-- larger than the indentation for The item.)
'--
Dim ctl As Control
'-- Short form...
Set ctl = frmOrgChart.Outline1
'-- Stop recursion at this point..
'-- Looks pretty stupid to use an if/end for this, but basic's OR checks doesn't skip
'-- the second case if the first evaluated to true, which in our case would result in
'-- a control error message.
If iIndex = ctl.ListCount Then
Exit Sub
ElseIf Not ctl.Indent(iIndex) > iIndent Then
Exit Sub
End If
PromoteChild iIndex + 1, iIndent
'-- Adjust indentation..
ctl.Indent(iIndex) = ctl.Indent(iIndex) - 1
End Sub
Sub PromoteItem()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function : frmOrgChart.mnuCommandItem()
'-- Functions called : PromoteChild()
'-- PromoteItem adjust the indentation of the item's child, and then adjust the indentation
'-- for the item itself. However, if the outline control is empty or the item's indentation
'-- level is smaller than 2, it'll just beep.
'--
Dim ctl As Control
'-- Short form...
Set ctl = frmOrgChart.Outline1
If ctl.ListIndex <> -1 Then
'-- Cannot promote an item with indent 0 or 1 since we want one root only..
If ctl.Indent(ctl.ListIndex) > 1 Then
PromoteChild ctl.ListIndex + 1, (ctl.Indent(ctl.ListIndex))
ctl.Indent(ctl.ListIndex) = ctl.Indent(ctl.ListIndex) - 1
UpdateFields
Else
Beep
End If
Else
Beep
End If
End Sub
Sub ReadOrgChart()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: frmOrgChart.mnuChartItem_Click()
'-- Functions called: BuildOneD(), BuildTwoD(), MergeStr(), ConvertStr(), ImportStr(),
'-- FindRoot()
'-- ReadOrgChart creates or get the excisting Visio, reads the number of shapes that are on the
'-- active document's page, seperates these shapes into one dimensional and two dimensional,
'-- merge the two sets in order to build the tree in the frmOrgChart's outline control
'--
Dim objDocument As Visio.Document
Dim cShapesCount As Integer, i As Integer
Dim strOneD As String, strTwoD As String, strRoot As String
On Error GoTo LBLReadOrgChartError
If vaoGetObject() <> visOK Then
MsgBox "Cannot achieve an instance of Visio!"
End
End If
'-- Make sure that the drawing window is the active window because if we delete
'-- a drawing window, the stencil window becomes active
For i = 1 To g_appVisio.Windows.Count
If g_appVisio.Windows(i).Type = visDrawing Then
g_appVisio.Windows(i).Activate
End If
Next i
Screen.MousePointer = CURSOR_HOURGLASS
Set objDocument = g_appVisio.ActiveDocument
cShapesCount = objDocument.Pages(1).Shapes.Count
strOneD = BuildOneD(cShapesCount, objDocument)
strTwoD = BuildTwoD(cShapesCount, objDocument)
If strOneD <> "" Then
MergeStr strOneD, strTwoD
End If
strRoot = FindRoot(strTwoD)
ConvertStr strTwoD, cShapesCount
frmOrgChart.Text1.Text = " "
frmOrgChart.Outline1.Clear
'-- Build the org chart tree in the outline control
ImportStr strTwoD, strRoot, 0
'-- Expand the tree
If frmOrgChart.mnuChartItem(ShowItems).Checked = True Then
For i = 1 To frmOrgChart.Outline1.ListCount - 1
TopExpand (i)
Next
End If
frmOrgChart.Outline1.ListIndex = frmOrgChart.Outline1.ListCount - 1
UpdateFields
Screen.MousePointer = CURSOR_NORMAL
Exit Sub
LBLReadOrgChartError:
If objDocument Is Nothing Then
MsgBox ("There is no open document in Visio")
End If
MsgBox Error$(Err)
Exit Sub
End Sub
Sub SuperExpand(Index As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling functions: frmOrgChart.mnuCommandItem(), text1.keydown(), text1.keyup(),
'-- general.movedown , DemoteChilde(), PromoteAll()
'-- Functions called : SuperExpand() - recursiv
'-- SuperExpand traverses the path backwards until it finds a parent which is visible, makes
'-- the children for this parent visible using the expand property, and calls itself recursively
'-- to see if the item (index) is now visible.
'--
Dim cCounter As Integer
If Not (frmOrgChart.Outline1.IsItemVisible(Index)) Then
cCounter = 1
Do While Not (frmOrgChart.Outline1.IsItemVisible(Index - cCounter))
cCounter = cCounter + 1
Loop
'***********************************
'-- This line sometimes has a side effect - it adds an item to the outline orgchart tree
'-- when user hits the TAB or SHIFT/TAB. Should be corrected.
frmOrgChart.Outline1.Expand(Index - cCounter) = True
SuperExpand (Index)
End If
End Sub
Function TopEngine(Index As Integer) As Integer
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling function: TopExpand()
'-- Functions called: TopEngine() - recursive
'--
Dim cCounter As Integer
cCounter = 1
If frmOrgChart.Outline1.HasSubItems(Index) Then
frmOrgChart.Outline1.Expand(Index) = True
Do While (frmOrgChart.Outline1.Indent(Index + cCounter) = frmOrgChart.Outline1.Indent(Index) + 1)
cCounter = cCounter + TopEngine(Index + cCounter)
If Index + cCounter >= frmOrgChart.Outline1.ListCount - 1 Then Exit Do
Loop
End If
TopEngine = cCounter
End Function
Sub TopExpand(Index As Integer)
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling functions :
'-- Functions called : TopEngine()
'-- TopExpands soul purpose is to call TopEngine() and to recieve whatever value it returns (a
'-- value which is not needed). TopEngine needs to be a function because it calls itself, and
'-- in VB you cannot ignore return values like in C. Since TopEngine needs to be called several
'-- times, TopExpand functions as a filter for the useless return value and saves us variable
'-- declarations everywhere else.
'--
Dim iCrap As Integer
iCrap = TopEngine(Index)
End Sub
Sub UpdateFields()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
'-- Calling functions: Form_Load(), frmOrgChart.mnuCommandItem_Click(), outline1.Click(),
'-- Text1.KeyDown(), Text1.KeyUp()
'-- Functions called :
'-- UpdateFields checks to see if there's anything in the form's outline control, and if so,
'-- updates the text control according to the outline controls text, and enables the menu item
'-- "CreateOrgChart". If the outline is blank, the text box is blanked, and the menu item is
'-- disabled.
'--
If Not (frmOrgChart.Outline1.ListIndex = 0 And frmOrgChart.Outline1.List(0) = "") Then
frmOrgChart.Text1.Text = frmOrgChart.Outline1.Text
frmOrgChart.mnuChartItem(CreateChart).Enabled = True
Else
frmOrgChart.Text1.Text = ""
frmOrgChart.mnuChartItem(CreateChart).Enabled = False
End If
End Sub